home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 January / macformat-020.iso / Shareware City / Developers / SIOD 3.0 / trace.c < prev   
Encoding:
C/C++ Source or Header  |  1994-10-01  |  3.5 KB  |  143 lines  |  [TEXT/ttxt]
  1. /*    COPYRIGHT (c) 1992-1994 BY
  2.  *    MITECH CORPORATION, ACTON, MASSACHUSETTS.
  3.  *    See the source file SLIB.C for more information.
  4.  
  5. (trace procedure1 procedure2 ...)
  6. (untrace procedure1 procedure2 ...)
  7.  
  8. Currently only user-defined procedures can be traced.
  9. Fancy printing features such as indentation based on
  10. recursion level will also have to wait for a future version.
  11.  
  12.  
  13.  */
  14.  
  15. #include <stdio.h>
  16. #include <setjmp.h>
  17. #include "siod.h"
  18. #include "siodp.h"
  19.  
  20. #define tc_closure_traced tc_sys_1
  21.  
  22. static LISP sym_traced = NIL;
  23. static LISP sym_quote = NIL;
  24. static LISP sym_begin = NIL;
  25.  
  26. LISP ltrace_fcn_name(LISP body);
  27. LISP ltrace_1(LISP fcn_name,LISP env);
  28. LISP ltrace(LISP fcn_names,LISP env);
  29. LISP luntrace_1(LISP fcn);
  30. LISP luntrace(LISP fcns);
  31. static void ct_gc_scan(LISP ptr);
  32. static LISP ct_gc_mark(LISP ptr);
  33. void ct_prin1(LISP ptr,FILE *f);
  34. LISP ct_eval(LISP ct,LISP *px,LISP *penv);
  35.  
  36. LISP ltrace_fcn_name(LISP body)
  37. {LISP tmp;
  38.  if NCONSP(body) return(NIL);
  39.  if NEQ(CAR(body),sym_begin) return(NIL);
  40.  tmp = CDR(body);
  41.  if NCONSP(tmp) return(NIL);
  42.  tmp = CAR(tmp);
  43.  if NCONSP(tmp) return(NIL);
  44.  if NEQ(CAR(tmp),sym_quote) return(NIL);
  45.  tmp = CDR(tmp);
  46.  if NCONSP(tmp) return(NIL);
  47.  return(CAR(tmp));}
  48.  
  49. LISP ltrace_1(LISP fcn_name,LISP env)
  50. {LISP fcn,code;
  51.  fcn = leval(fcn_name,env);
  52.  switch TYPE(fcn)
  53.    {case tc_closure:
  54.       code = fcn->storage_as.closure.code;
  55.       if NULLP(ltrace_fcn_name(cdr(code)))
  56.     setcdr(code,cons(sym_begin,
  57.              cons(cons(sym_quote,cons(fcn_name,NIL)),
  58.                   cons(cdr(code),NIL))));
  59.       fcn->type = tc_closure_traced;
  60.       break;
  61.     case tc_closure_traced:
  62.       break;
  63.     default:
  64.       err("not a closure, cannot trace",fcn);}
  65.  return(NIL);}
  66.  
  67. LISP ltrace(LISP fcn_names,LISP env)
  68. {LISP l;
  69.  for(l=fcn_names;NNULLP(l);l=cdr(l))
  70.    ltrace_1(car(l),env);
  71.  return(NIL);}
  72.  
  73. LISP luntrace_1(LISP fcn)
  74. {switch TYPE(fcn)
  75.    {case tc_closure:
  76.       break;
  77.     case tc_closure_traced:
  78.       fcn->type = tc_closure;
  79.       break;
  80.     default:
  81.       err("not a closure, cannot untrace",fcn);}
  82.  return(NIL);}
  83.  
  84. LISP luntrace(LISP fcns)
  85. {LISP l;
  86.  for(l=fcns;NNULLP(l);l=cdr(l))
  87.    luntrace_1(car(l));
  88.  return(NIL);}
  89.  
  90. static void ct_gc_scan(LISP ptr)
  91. {CAR(ptr) = gc_relocate(CAR(ptr));
  92.  CDR(ptr) = gc_relocate(CDR(ptr));}
  93.  
  94. static LISP ct_gc_mark(LISP ptr)
  95. {gc_mark(ptr->storage_as.closure.code);
  96.  return(ptr->storage_as.closure.env);}
  97.  
  98. void ct_prin1(LISP ptr,FILE *f)
  99. {fput_st(f,"#<CLOSURE(TRACED) ");
  100.  lprin1f(car(ptr->storage_as.closure.code),f);
  101.  fput_st(f," ");
  102.  lprin1f(cdr(ptr->storage_as.closure.code),f);
  103.  fput_st(f,">");}
  104.  
  105. LISP ct_eval(LISP ct,LISP *px,LISP *penv)
  106. {LISP fcn_name,args,env,result,l;
  107.  fcn_name = ltrace_fcn_name(cdr(ct->storage_as.closure.code));
  108.  args = leval_args(CDR(*px),*penv);
  109.  fput_st(stdout,"->");
  110.  lprin1f(fcn_name,stdout);
  111.  for(l=args;NNULLP(l);l=cdr(l))
  112.    {fput_st(stdout," ");
  113.     lprin1f(car(l),stdout);}
  114.  fput_st(stdout,"\n");
  115.  env = extend_env(args,
  116.           car(ct->storage_as.closure.code),
  117.           ct->storage_as.closure.env);
  118.  result = leval(cdr(ct->storage_as.closure.code),env);
  119.  fput_st(stdout,"<-");
  120.  lprin1f(fcn_name,stdout);
  121.  fput_st(stdout," ");
  122.  lprin1f(result,stdout);
  123.  fput_st(stdout,"\n");
  124.  *px = result;
  125.  return(NIL);}
  126.  
  127. void init_trace(void)
  128. {long j;
  129.  set_gc_hooks(tc_closure_traced,
  130.           NULL,
  131.           ct_gc_mark,
  132.           ct_gc_scan,
  133.           NULL,
  134.           &j);
  135.  gc_protect_sym(&sym_traced,"*traced*");
  136.  setvar(sym_traced,NIL,NIL);
  137.  gc_protect_sym(&sym_begin,"begin");
  138.  gc_protect_sym(&sym_quote,"quote");
  139.  set_print_hooks(tc_closure_traced,ct_prin1);
  140.  set_eval_hooks(tc_closure_traced,ct_eval);
  141.  init_fsubr("trace",ltrace);
  142.  init_lsubr("untrace",luntrace);}
  143.